home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / OldSrc / CH13 / SRC / RAY2.FRM (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1997-01-08  |  30.2 KB  |  926 lines
  1. VERSION 4.00
  2. Begin VB.Form RayForm 
  3.    Appearance      =   0  'Flat
  4.    Caption         =   "Ray2"
  5.    ClientHeight    =   4005
  6.    ClientLeft      =   1905
  7.    ClientTop       =   1320
  8.    ClientWidth     =   6030
  9.    BeginProperty Font 
  10.       name            =   "MS Sans Serif"
  11.       charset         =   0
  12.       weight          =   700
  13.       size            =   8.25
  14.       underline       =   0   'False
  15.       italic          =   0   'False
  16.       strikethrough   =   0   'False
  17.    EndProperty
  18.    ForeColor       =   &H80000008&
  19.    Height          =   4695
  20.    KeyPreview      =   -1  'True
  21.    Left            =   1845
  22.    LinkTopic       =   "Form1"
  23.    ScaleHeight     =   267
  24.    ScaleMode       =   3  'Pixel
  25.    ScaleWidth      =   402
  26.    Top             =   690
  27.    Width           =   6150
  28.    Begin VB.OptionButton Scene 
  29.       Caption         =   "Spheres + Cylinders"
  30.       BeginProperty Font 
  31.          name            =   "MS Sans Serif"
  32.          charset         =   0
  33.          weight          =   700
  34.          size            =   8.25
  35.          underline       =   0   'False
  36.          italic          =   0   'False
  37.          strikethrough   =   0   'False
  38.       EndProperty
  39.       Height          =   255
  40.       Index           =   3
  41.       Left            =   0
  42.       TabIndex        =   16
  43.       Top             =   1080
  44.       Width           =   2025
  45.    End
  46.    Begin VB.OptionButton Scene 
  47.       Caption         =   "Sphere + Cube"
  48.       BeginProperty Font 
  49.          name            =   "MS Sans Serif"
  50.          charset         =   0
  51.          weight          =   700
  52.          size            =   8.25
  53.          underline       =   0   'False
  54.          italic          =   0   'False
  55.          strikethrough   =   0   'False
  56.       EndProperty
  57.       Height          =   255
  58.       Index           =   2
  59.       Left            =   0
  60.       TabIndex        =   15
  61.       Top             =   720
  62.       Width           =   2025
  63.    End
  64.    Begin VB.OptionButton Scene 
  65.       Caption         =   "Sphere + Square"
  66.       BeginProperty Font 
  67.          name            =   "MS Sans Serif"
  68.          charset         =   0
  69.          weight          =   700
  70.          size            =   8.25
  71.          underline       =   0   'False
  72.          italic          =   0   'False
  73.          strikethrough   =   0   'False
  74.       EndProperty
  75.       Height          =   255
  76.       Index           =   1
  77.       Left            =   0
  78.       TabIndex        =   14
  79.       Top             =   360
  80.       Width           =   2025
  81.    End
  82.    Begin VB.OptionButton Scene 
  83.       Caption         =   "Spheres + Plane"
  84.       BeginProperty Font 
  85.          name            =   "MS Sans Serif"
  86.          charset         =   0
  87.          weight          =   700
  88.          size            =   8.25
  89.          underline       =   0   'False
  90.          italic          =   0   'False
  91.          strikethrough   =   0   'False
  92.       EndProperty
  93.       Height          =   255
  94.       Index           =   0
  95.       Left            =   0
  96.       TabIndex        =   13
  97.       Top             =   0
  98.       Value           =   -1  'True
  99.       Width           =   2025
  100.    End
  101.    Begin VB.TextBox StepText 
  102.       BeginProperty Font 
  103.          name            =   "MS Sans Serif"
  104.          charset         =   0
  105.          weight          =   700
  106.          size            =   8.25
  107.          underline       =   0   'False
  108.          italic          =   0   'False
  109.          strikethrough   =   0   'False
  110.       EndProperty
  111.       Height          =   285
  112.       Left            =   840
  113.       TabIndex        =   11
  114.       Text            =   "4"
  115.       Top             =   3240
  116.       Width           =   855
  117.    End
  118.    Begin VB.CommandButton CmdGo 
  119.       Caption         =   "Go"
  120.       Default         =   -1  'True
  121.       BeginProperty Font 
  122.          name            =   "MS Sans Serif"
  123.          charset         =   0
  124.          weight          =   700
  125.          size            =   8.25
  126.          underline       =   0   'False
  127.          italic          =   0   'False
  128.          strikethrough   =   0   'False
  129.       EndProperty
  130.       Height          =   375
  131.       Left            =   600
  132.       TabIndex        =   10
  133.       Top             =   3600
  134.       Width           =   1095
  135.    End
  136.    Begin VB.TextBox KdistText 
  137.       BeginProperty Font 
  138.          name            =   "MS Sans Serif"
  139.          charset         =   0
  140.          weight          =   700
  141.          size            =   8.25
  142.          underline       =   0   'False
  143.          italic          =   0   'False
  144.          strikethrough   =   0   'False
  145.       EndProperty
  146.       Height          =   285
  147.       Left            =   840
  148.       TabIndex        =   7
  149.       Text            =   "-850"
  150.       Top             =   2640
  151.       Width           =   855
  152.    End
  153.    Begin VB.TextBox PhiText 
  154.       BeginProperty Font 
  155.          name            =   "MS Sans Serif"
  156.          charset         =   0
  157.          weight          =   700
  158.          size            =   8.25
  159.          underline       =   0   'False
  160.          italic          =   0   'False
  161.          strikethrough   =   0   'False
  162.       EndProperty
  163.       Height          =   285
  164.       Left            =   840
  165.       TabIndex        =   6
  166.       Text            =   "-0.4713"
  167.       Top             =   2160
  168.       Width           =   855
  169.    End
  170.    Begin VB.TextBox ThetaText 
  171.       BeginProperty Font 
  172.          name            =   "MS Sans Serif"
  173.          charset         =   0
  174.          weight          =   700
  175.          size            =   8.25
  176.          underline       =   0   'False
  177.          italic          =   0   'False
  178.          strikethrough   =   0   'False
  179.       EndProperty
  180.       Height          =   285
  181.       Left            =   840
  182.       TabIndex        =   4
  183.       Text            =   "0.6275"
  184.       Top             =   1800
  185.       Width           =   855
  186.    End
  187.    Begin VB.TextBox RText 
  188.       BeginProperty Font 
  189.          name            =   "MS Sans Serif"
  190.          charset         =   0
  191.          weight          =   700
  192.          size            =   8.25
  193.          underline       =   0   'False
  194.          italic          =   0   'False
  195.          strikethrough   =   0   'False
  196.       EndProperty
  197.       Height          =   285
  198.       Left            =   840
  199.       TabIndex        =   2
  200.       Text            =   "1000"
  201.       Top             =   1440
  202.       Width           =   855
  203.    End
  204.    Begin VB.PictureBox Pict 
  205.       AutoRedraw      =   -1  'True
  206.       BackColor       =   &H00FFFF80&
  207.       BeginProperty Font 
  208.          name            =   "MS Sans Serif"
  209.          charset         =   0
  210.          weight          =   700
  211.          size            =   8.25
  212.          underline       =   0   'False
  213.          italic          =   0   'False
  214.          strikethrough   =   0   'False
  215.       EndProperty
  216.       Height          =   3975
  217.       Left            =   2040
  218.       Picture         =   "Ray2.frx":0000
  219.       ScaleHeight     =   261
  220.       ScaleMode       =   3  'Pixel
  221.       ScaleWidth      =   261
  222.       TabIndex        =   0
  223.       Top             =   0
  224.       Width           =   3975
  225.    End
  226.    Begin VB.Label Label1 
  227.       Caption         =   "Step"
  228.       BeginProperty Font 
  229.          name            =   "MS Sans Serif"
  230.          charset         =   0
  231.          weight          =   700
  232.          size            =   8.25
  233.          underline       =   0   'False
  234.          italic          =   0   'False
  235.          strikethrough   =   0   'False
  236.       EndProperty
  237.       Height          =   255
  238.       Index           =   13
  239.       Left            =   240
  240.       TabIndex        =   12
  241.       Top             =   3240
  242.       Width           =   615
  243.    End
  244.    Begin VB.Label Label1 
  245.       Caption         =   "dist"
  246.       BeginProperty Font 
  247.          name            =   "MS Sans Serif"
  248.          charset         =   0
  249.          weight          =   700
  250.          size            =   8.25
  251.          underline       =   0   'False
  252.          italic          =   0   'False
  253.          strikethrough   =   0   'False
  254.       EndProperty
  255.       Height          =   255
  256.       Index           =   8
  257.       Left            =   360
  258.       TabIndex        =   9
  259.       Top             =   2760
  260.       Width           =   375
  261.    End
  262.    Begin VB.Label Label1 
  263.       Caption         =   "k"
  264.       BeginProperty Font 
  265.          name            =   "MS Sans Serif"
  266.          charset         =   0
  267.          weight          =   700
  268.          size            =   8.25
  269.          underline       =   0   'False
  270.          italic          =   0   'False
  271.          strikethrough   =   0   'False
  272.       EndProperty
  273.       Height          =   255
  274.       Index           =   6
  275.       Left            =   240
  276.       TabIndex        =   8
  277.       Top             =   2640
  278.       Width           =   135
  279.    End
  280.    Begin MSComDlg.CommonDialog LoadDialog 
  281.       Left            =   0
  282.       Top             =   3720
  283.       _Version        =   65536
  284.       _ExtentX        =   847
  285.       _ExtentY        =   847
  286.       _StockProps     =   0
  287.       CancelError     =   -1  'True
  288.    End
  289.    Begin VB.Label Label1 
  290.       Caption         =   "Phi"
  291.       BeginProperty Font 
  292.          name            =   "MS Sans Serif"
  293.          charset         =   0
  294.          weight          =   700
  295.          size            =   8.25
  296.          underline       =   0   'False
  297.          italic          =   0   'False
  298.          strikethrough   =   0   'False
  299.       EndProperty
  300.       Height          =   255
  301.       Index           =   2
  302.       Left            =   240
  303.       TabIndex        =   5
  304.       Top             =   2160
  305.       Width           =   375
  306.    End
  307.    Begin VB.Label Label1 
  308.       Caption         =   "Theta"
  309.       BeginProperty Font 
  310.          name            =   "MS Sans Serif"
  311.          charset         =   0
  312.          weight          =   700
  313.          size            =   8.25
  314.          underline       =   0   'False
  315.          italic          =   0   'False
  316.          strikethrough   =   0   'False
  317.       EndProperty
  318.       Height          =   255
  319.       Index           =   1
  320.       Left            =   240
  321.       TabIndex        =   3
  322.       Top             =   1800
  323.       Width           =   495
  324.    End
  325.    Begin VB.Label Label1 
  326.       Caption         =   "R"
  327.       BeginProperty Font 
  328.          name            =   "MS Sans Serif"
  329.          charset         =   0
  330.          weight          =   700
  331.          size            =   8.25
  332.          underline       =   0   'False
  333.          italic          =   0   'False
  334.          strikethrough   =   0   'False
  335.       EndProperty
  336.       Height          =   255
  337.       Index           =   0
  338.       Left            =   240
  339.       TabIndex        =   1
  340.       Top             =   1440
  341.       Width           =   255
  342.    End
  343.    Begin VB.Menu mnuFile 
  344.       Caption         =   "&File"
  345.       Begin VB.Menu mnuFileSaveBitmap 
  346.          Caption         =   "&Save Bitmap..."
  347.          Shortcut        =   ^S
  348.       End
  349.       Begin VB.Menu mnuFileSep 
  350.          Caption         =   "-"
  351.       End
  352.       Begin VB.Menu mnuFileExit 
  353.          Caption         =   "E&xit"
  354.       End
  355.    End
  356. Attribute VB_Name = "RayForm"
  357. Attribute VB_Creatable = False
  358. Attribute VB_Exposed = False
  359. Option Explicit
  360. Dim SysPalSize As Integer
  361. Dim NumStaticColors As Integer
  362. Dim StaticColor1 As Integer
  363. Dim StaticColor2 As Integer
  364. Dim syspal(0 To 255) As PALETTEENTRY
  365. ' Location of viewing eye.
  366. Dim EyeR As Single
  367. Dim EyeTheta As Single
  368. Dim EyePhi As Single
  369. Const dtheta = PI / 20
  370. Const Dphi = PI / 20
  371. Const dR = 1
  372. ' Location of focus point.
  373. Const FocusX = 0#
  374. Const FocusY = 0#
  375. Const FocusZ = 0#
  376. Dim Projector(1 To 4, 1 To 4) As Single
  377. ' The collection of objects in the scene.
  378. Dim Objects As Collection
  379. Dim Running As Boolean
  380. Dim SceneChoice As Integer
  381. ' ************************************************
  382. ' Halt immediately in case we're in the middle of
  383. ' ray tracing.
  384. ' ************************************************
  385. Private Sub Form_Unload(Cancel As Integer)
  386.     End
  387. End Sub
  388. ' ************************************************
  389. ' Create the objects in the scene.
  390. ' ************************************************
  391. Sub CreateData()
  392. Dim obj As Object
  393. Dim s As Single
  394.     Set Objects = New Collection
  395.     Select Case SceneChoice
  396.         Case 0  ' Spheres + Plane.
  397.             ' Sphere of radius 60 at (-40, 0, 0).
  398.             Set obj = New ObjSphere
  399.             Objects.Add obj
  400.             obj.Initialize 60, -40, 0, 0
  401.             obj.SetKd 0.45, 0.45, 0.45  ' Diffuse.
  402.             obj.SetKa 0.4, 0.4, 0.4     ' Ambient.
  403.             obj.SetSpec 20, 0.35        ' Specular.
  404.         
  405.             ' Sphere of radius 60 at (40, 0, 0).
  406.             Set obj = New ObjSphere
  407.             Objects.Add obj
  408.             obj.Initialize 60, 40, 0, 0
  409.             obj.SetKd 0.45, 0.45, 0.45  ' Diffuse.
  410.             obj.SetKa 0.4, 0.4, 0.4     ' Ambient.
  411.             obj.SetSpec 20, 0.35        ' Specular.
  412.         
  413.             ' X-Z plane.
  414.             Set obj = New ObjPlane
  415.             Objects.Add obj
  416.             obj.Initialize 0, 0, 0, 0, -1, 0
  417.             obj.SetKd 0.45, 0.45, 0.45  ' Diffuse.
  418.             obj.SetKa 0.3, 0.3, 0.3     ' Ambient.
  419.             obj.SetSpec 20, 0.35        ' Specular.
  420.         Case 1  ' Sphere + Square.
  421.             ' Sphere of radius 70 at (0, 0, 0).
  422.             Set obj = New ObjSphere
  423.             Objects.Add obj
  424.             obj.Initialize 70, 0, 0, 0
  425.             obj.SetKd 0.45, 0.45, 0.45  ' Diffuse.
  426.             obj.SetKa 0.4, 0.4, 0.4     ' Ambient.
  427.             obj.SetSpec 20, 0.35        ' Specular.
  428.             ' Square in the X-Z plane with side
  429.             ' length 160.
  430.             Set obj = New ObjPolygon
  431.             Objects.Add obj
  432.             obj.AddPoint _
  433.                 80, 0, 80, _
  434.                 -80, 0, 80, _
  435.                 -80, 0, -80, _
  436.                 80, 0, -80
  437.             obj.DefinePlane
  438.             obj.SetKd 0.45, 0.45, 0.45  ' Diffuse.
  439.             obj.SetKa 0.3, 0.3, 0.3     ' Ambient.
  440.             obj.SetSpec 20, 0.35        ' Specular.
  441.         Case 2  ' Sphere + Cube.
  442.             s = 70
  443.             ' Sphere of radius s * Sqr(2) at (0, 0, 0).
  444.             Set obj = New ObjSphere
  445.             Objects.Add obj
  446.             obj.Initialize s * Sqr(2), 0, 0, 0
  447.             obj.SetKd 0.45, 0.45, 0.45  ' Diffuse.
  448.             obj.SetKa 0.4, 0.4, 0.4     ' Ambient.
  449.             obj.SetSpec 20, 0.35        ' Specular.
  450.             ' X+ side.
  451.             Set obj = New ObjPolygon
  452.             Objects.Add obj
  453.             obj.AddPoint _
  454.                 s, s, s, _
  455.                 s, -s, s, _
  456.                 s, -s, -s, _
  457.                 s, s, -s
  458.             obj.DefinePlane
  459.             obj.SetKd 0.45, 0.45, 0.45  ' Diffuse.
  460.             obj.SetKa 0.3, 0.3, 0.3     ' Ambient.
  461.             obj.SetSpec 20, 0.35        ' Specular.
  462.             ' X- side.
  463.             Set obj = New ObjPolygon
  464.             Objects.Add obj
  465.             obj.AddPoint _
  466.                 -s, s, s, _
  467.                 -s, -s, s, _
  468.                 -s, -s, -s, _
  469.                 -s, s, -s
  470.             obj.DefinePlane
  471.             obj.SetKd 0.45, 0.45, 0.45  ' Diffuse.
  472.             obj.SetKa 0.3, 0.3, 0.3     ' Ambient.
  473.             obj.SetSpec 20, 0.35        ' Specular.
  474.             ' Y+ side.
  475.             Set obj = New ObjPolygon
  476.             Objects.Add obj
  477.             obj.AddPoint _
  478.                 s, s, s, _
  479.                 -s, s, s, _
  480.                 -s, s, -s, _
  481.                 s, s, -s
  482.             obj.DefinePlane
  483.             obj.SetKd 0.45, 0.45, 0.45  ' Diffuse.
  484.             obj.SetKa 0.3, 0.3, 0.3     ' Ambient.
  485.             obj.SetSpec 20, 0.35        ' Specular.
  486.             ' Y- side.
  487.             Set obj = New ObjPolygon
  488.             Objects.Add obj
  489.             obj.AddPoint _
  490.                 s, -s, s, _
  491.                 -s, -s, s, _
  492.                 -s, -s, -s, _
  493.                 s, -s, -s
  494.             obj.DefinePlane
  495.             obj.SetKd 0.45, 0.45, 0.45  ' Diffuse.
  496.             obj.SetKa 0.3, 0.3, 0.3     ' Ambient.
  497.             obj.SetSpec 20, 0.35        ' Specular.
  498.             ' Z+ side.
  499.             Set obj = New ObjPolygon
  500.             Objects.Add obj
  501.             obj.AddPoint _
  502.                 s, s, s, _
  503.                 -s, s, s, _
  504.                 -s, -s, s, _
  505.                 s, -s, s
  506.             obj.DefinePlane
  507.             obj.SetKd 0.45, 0.45, 0.45  ' Diffuse.
  508.             obj.SetKa 0.3, 0.3, 0.3     ' Ambient.
  509.             obj.SetSpec 20, 0.35        ' Specular.
  510.             ' Z- side.
  511.             Set obj = New ObjPolygon
  512.             Objects.Add obj
  513.             obj.AddPoint _
  514.                 s, s, -s, _
  515.                 -s, s, -s, _
  516.                 -s, -s, -s, _
  517.                 s, -s, -s
  518.             obj.DefinePlane
  519.             obj.SetKd 0.45, 0.45, 0.45  ' Diffuse.
  520.             obj.SetKa 0.3, 0.3, 0.3     ' Ambient.
  521.             obj.SetSpec 20, 0.35        ' Specular.
  522.         Case 3  ' Spheres + Cylinders.
  523.             s = 15
  524.             ' Cylinder of radius s between
  525.             ' (-100, 0, 0) and (100, 0, 0).
  526.             Set obj = New ObjCylinder
  527.             Objects.Add obj
  528.             obj.Initialize s, -100, 0, 0, 100, 0, 0
  529.             obj.SetKd 0.45, 0.45, 0.45  ' Diffuse.
  530.             obj.SetKa 0.4, 0.4, 0.4     ' Ambient.
  531.             obj.SetSpec 20, 0.35        ' Specular.
  532.                     
  533.             ' Cylinder of radius s between
  534.             ' (0, -100, 0) and (0, 100, 0).
  535.             Set obj = New ObjCylinder
  536.             Objects.Add obj
  537.             obj.Initialize s, 0, -100, 0, 0, 100, 0
  538.             obj.SetKd 0.45, 0.45, 0.45  ' Diffuse.
  539.             obj.SetKa 0.4, 0.4, 0.4     ' Ambient.
  540.             obj.SetSpec 20, 0.35        ' Specular.
  541.                     
  542.             ' Cylinder of radius s between
  543.             ' (0, 0, -100) and (0, 0, 100).
  544.             Set obj = New ObjCylinder
  545.             Objects.Add obj
  546.             obj.Initialize s, 0, 0, -100, 0, 0, 100
  547.             obj.SetKd 0.45, 0.45, 0.45  ' Diffuse.
  548.             obj.SetKa 0.4, 0.4, 0.4     ' Ambient.
  549.             obj.SetSpec 20, 0.35        ' Specular.
  550.                     
  551.             s = 30
  552.             ' Sphere of radius s at (-100, 0, 0).
  553.             Set obj = New ObjSphere
  554.             Objects.Add obj
  555.             obj.Initialize s, -100, 0, 0
  556.             obj.SetKd 0.45, 0.45, 0.45  ' Diffuse.
  557.             obj.SetKa 0.4, 0.4, 0.4     ' Ambient.
  558.             obj.SetSpec 20, 0.35        ' Specular.
  559.             ' Sphere of radius s at (100, 0, 0).
  560.             Set obj = New ObjSphere
  561.             Objects.Add obj
  562.             obj.Initialize s, 100, 0, 0
  563.             obj.SetKd 0.45, 0.45, 0.45  ' Diffuse.
  564.             obj.SetKa 0.4, 0.4, 0.4     ' Ambient.
  565.             obj.SetSpec 20, 0.35        ' Specular.
  566.             ' Sphere of radius s at (0, -100, 0).
  567.             Set obj = New ObjSphere
  568.             Objects.Add obj
  569.             obj.Initialize s, 0, -100, 0
  570.             obj.SetKd 0.45, 0.45, 0.45  ' Diffuse.
  571.             obj.SetKa 0.4, 0.4, 0.4     ' Ambient.
  572.             obj.SetSpec 20, 0.35        ' Specular.
  573.             ' Sphere of radius s at (0, 100, 0).
  574.             Set obj = New ObjSphere
  575.             Objects.Add obj
  576.             obj.Initialize s, 0, 100, 0
  577.             obj.SetKd 0.45, 0.45, 0.45  ' Diffuse.
  578.             obj.SetKa 0.4, 0.4, 0.4     ' Ambient.
  579.             obj.SetSpec 20, 0.35        ' Specular.
  580.             ' Sphere of radius s at (0, 0, -100).
  581.             Set obj = New ObjSphere
  582.             Objects.Add obj
  583.             obj.Initialize s, 0, 0, -100
  584.             obj.SetKd 0.45, 0.45, 0.45  ' Diffuse.
  585.             obj.SetKa 0.4, 0.4, 0.4     ' Ambient.
  586.             obj.SetSpec 20, 0.35        ' Specular.
  587.             
  588.             ' Sphere of radius s at (0, 0, 100).
  589.             Set obj = New ObjSphere
  590.             Objects.Add obj
  591.             obj.Initialize s, 0, 0, 100
  592.             obj.SetKd 0.45, 0.45, 0.45  ' Diffuse.
  593.             obj.SetKa 0.4, 0.4, 0.4     ' Ambient.
  594.             obj.SetSpec 20, 0.35        ' Specular.
  595.     End Select
  596. End Sub
  597. ' *******************************************************
  598. ' Project and draw.
  599. ' *******************************************************
  600. Private Sub DrawData(pic As Object)
  601. Dim Projector(1 To 4, 1 To 4) As Single
  602. Dim obj As Object
  603. Dim factor As Single
  604.     ' Get the current eye location.
  605.     EyeR = CSng(RText.Text)
  606.     EyeTheta = CSng(ThetaText.Text)
  607.     EyePhi = CSng(PhiText.Text)
  608.     ' Create the data.
  609.     CreateData
  610.     ' Get constants for the surfaces.
  611.     LightKdist = CSng(KdistText.Text)
  612.     ' Create a background color.
  613.     BackR = 0
  614.     BackG = 0
  615.     BackB = 0
  616.     ' Fill with another color so we can see progress.
  617.     pic.Line (pic.ScaleLeft, pic.ScaleTop)- _
  618.         Step(pic.ScaleWidth, pic.ScaleHeight), _
  619.         RGB(0, 0, &H80), BF
  620.     ' Rotate the eye onto the Z axis.
  621.     m3PProject Projector, m3Parallel, _
  622.         EyeR, EyePhi, EyeTheta, _
  623.         FocusX, FocusY, FocusZ, _
  624.         0, 1, 0
  625.     ' Transform the objects.
  626.     For Each obj In Objects
  627.         obj.Apply Projector
  628.     Next obj
  629.     ' Transform the light source.
  630.     m3Apply LightSource.coord, Projector, LightSource.trans
  631.     ' Adjust the incident light values.
  632.     factor = _
  633.         Sqr(LightSource.trans(1) * LightSource.trans(1) + _
  634.             LightSource.trans(2) * LightSource.trans(2) + _
  635.             LightSource.trans(3) * LightSource.trans(3)) _
  636.             + LightKdist + 4
  637.     LightIir = 255 * factor
  638.     LightIig = 255 * factor
  639.     LightIib = 255 * factor
  640.     ' Display the data.
  641.     RayTrace pic, CInt(StepText.Text)
  642.     ' Display the viewing parameters.
  643.     ShowViewingParameters
  644. End Sub
  645. ' ************************************************
  646. ' Start ray tracing for this picture box.
  647. ' ************************************************
  648. Sub RayTrace(pic As PictureBox, skip As Integer)
  649. Dim x As Integer
  650. Dim y As Integer
  651. Dim xmax As Integer
  652. Dim ymax As Integer
  653. Dim xoff As Integer
  654. Dim yoff As Integer
  655.     ' Get the transformed coordinates of the eye.
  656.     EyeX = 0
  657.     EyeY = 0
  658.     EyeZ = EyeR
  659.     xoff = pic.ScaleWidth / 2
  660.     yoff = pic.ScaleHeight / 2
  661.     xmax = pic.ScaleLeft + pic.ScaleWidth - 1
  662.     ymax = pic.ScaleTop + pic.ScaleHeight - 1
  663.     For y = pic.ScaleTop To ymax Step skip
  664.         For x = pic.ScaleLeft To xmax Step skip
  665.             ' Calculate the value of pixel (x, y).
  666.             ' After transformation the eye is
  667.             ' at (0, 0, EyeR) and the plane of
  668.             ' projection lies in the X-Y plane.
  669.             If skip < 2 Then
  670.                 pic.PSet (x, y), _
  671.                     TraceRay(0, 0, EyeR, CSng(x) - xoff, CSng(y) - yoff, -EyeR)
  672.                 Else
  673.                     pic.Line (x, y)-Step(skip - 1, skip - 1), _
  674.                         TraceRay(0, 0, EyeR, CSng(x) - xoff, CSng(y) - yoff, -EyeR), BF
  675.                 End If
  676.         Next x
  677.         
  678.         ' Let the user see what's going on.
  679.         pic.Refresh
  680.         
  681.         ' If the Stop button was pressed, stop.
  682.         DoEvents
  683.         If Not Running Then Exit Sub
  684.     Next y
  685. End Sub
  686. Sub ShowViewingParameters()
  687.     RText.Text = Format$(EyeR, "0")
  688.     ThetaText.Text = Format$(EyeTheta, "0.0000")
  689.     PhiText.Text = Format$(EyePhi, "0.0000")
  690.     RText.Refresh
  691.     ThetaText.Refresh
  692.     PhiText.Refresh
  693. End Sub
  694. ' ************************************************
  695. ' Return the pixel color given by tracing from
  696. ' point (px, py, pz) in direction <vx, vy, vz>.
  697. ' ************************************************
  698. Function TraceRay(px As Single, py As Single, pz As Single, Vx As Single, Vy As Single, Vz As Single) As Long
  699. Dim i As Integer
  700. Dim best_i As Integer
  701. Dim best_dist As Single
  702. Dim dist As Single
  703. Dim r As Integer
  704. Dim G As Integer
  705. Dim B As Integer
  706.     If Objects.Count < 1 Then Exit Function
  707.     ' Find the object that's closest.
  708.     best_dist = INFINITY
  709.     best_i = -1
  710.     For i = 1 To Objects.Count
  711.         dist = Objects.Item(i).RayDistance( _
  712.             px, py, pz, Vx, Vy, Vz)
  713.         If best_dist > dist Then
  714.             best_dist = dist
  715.             best_i = i
  716.         End If
  717.     Next i
  718.     ' If we hit nothing, return the background color.
  719.     If best_i < 1 Then
  720.         TraceRay = &H2000000 + _
  721.             RGB(BackR, BackG, BackB)
  722.         Exit Function
  723.     End If
  724.     ' Compute the color at that point.
  725.     Objects.Item(best_i).HitColor Objects, r, G, B
  726.     ' This is a problem for some values of LightKdist.
  727.     If r < 0 Then r = 0
  728.     If G < 0 Then G = 0
  729.     If B < 0 Then B = 0
  730.     TraceRay = &H2000000 + RGB(r, G, B)
  731. End Function
  732. ' ************************************************
  733. ' Do the ray tracing.
  734. ' ************************************************
  735. Private Sub CmdGo_Click()
  736.     If Running Then
  737.         Running = False
  738.         CmdGo.Caption = "Stopped"
  739.         CmdGo.Enabled = False
  740.         DoEvents
  741.     Else
  742.         Running = True
  743.         CmdGo.Caption = "Stop"
  744.         MousePointer = vbHourglass
  745.         DoEvents
  746.         
  747.         DrawData Pict
  748.         
  749.         MousePointer = vbDefault
  750.         CmdGo.Enabled = True
  751.         CmdGo.Caption = "Go"
  752.         Running = False
  753.         Beep
  754.     End If
  755. End Sub
  756. Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
  757.     Select Case KeyCode
  758.         Case vbKeyLeft
  759.             EyeTheta = EyeTheta - dtheta
  760.         
  761.         Case vbKeyRight
  762.             EyeTheta = EyeTheta + dtheta
  763.         
  764.         Case vbKeyUp
  765.             EyePhi = EyePhi - Dphi
  766.         
  767.         Case vbKeyDown
  768.             EyePhi = EyePhi + Dphi
  769.                 
  770.         Case Else
  771.             Exit Sub
  772.     End Select
  773.     ShowViewingParameters
  774. End Sub
  775. Private Sub Form_KeyPress(KeyAscii As Integer)
  776.     Select Case KeyAscii
  777.         Case Asc("+")
  778.             EyeR = EyeR + dR
  779.         
  780.         Case Asc("-")
  781.             EyeR = EyeR - dR
  782.         
  783.         Case Else
  784.             Exit Sub
  785.     End Select
  786.     ShowViewingParameters
  787. End Sub
  788. Private Sub Form_Load()
  789.     ' Make sure the screen supports palettes.
  790.     If Not GetDeviceCaps(hdc, RASTERCAPS) And RC_PALETTE Then
  791.         Beep
  792.         MsgBox "This monitor does not support palettes.", _
  793.             vbCritical
  794.         End
  795.     End If
  796.     ' Get system palette size and # static colors.
  797.     SysPalSize = GetDeviceCaps(hdc, SIZEPALETTE)
  798.     NumStaticColors = GetDeviceCaps(hdc, NUMRESERVED)
  799.     StaticColor1 = NumStaticColors \ 2 - 1
  800.     StaticColor2 = SysPalSize - NumStaticColors \ 2
  801.     ' Fill the picture's palette with grays.
  802.     MatchGrayPalette Pict
  803.     Pict.Cls
  804.     ' Initialize lighting constants.
  805.     LightSource.coord(1) = 100
  806.     LightSource.coord(2) = -500
  807.     LightSource.coord(3) = 1000
  808.     LightSource.coord(4) = 1
  809.     LightIar = 128
  810.     LightIag = 128
  811.     LightIab = 128
  812.     ' Initialize the eye position.
  813.     EyeR = CSng(RText.Text)
  814.     EyeTheta = CSng(ThetaText.Text)
  815.     EyePhi = CSng(PhiText.Text)
  816.     ' Initialize the projection transformation.
  817.     m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
  818. End Sub
  819. ' ***********************************************
  820. ' Load the control's palette so the non-static
  821. ' colors are grays. Map the logical palette to
  822. ' match the system palette. Convert the image to
  823. ' use the non-static grays.
  824. ' Leave new system palette entries in SysPal().
  825. ' ***********************************************
  826. Sub MatchGrayPalette(pic As Control)
  827. Dim origpal(0 To 255) As PALETTEENTRY
  828. Dim wid As Long
  829. Dim hgt As Long
  830. Dim bytes() As Byte
  831. Dim i As Integer
  832. Dim bm As BITMAP
  833. Dim hbm As Integer
  834. Dim status As Long
  835. Dim x As Integer
  836. Dim y As Integer
  837. Dim gray As Single
  838. Dim dgray As Single
  839. Dim C As Integer
  840. Dim clr As Integer
  841. Dim logpal As Long
  842.     ' Make sure pic has the foreground palette.
  843.     pic.ZOrder
  844.     status = RealizePalette(pic.hdc)
  845.     DoEvents
  846.     ' Get the system palette entries.
  847.     status = GetSystemPaletteEntries(pic.hdc, 0, SysPalSize, origpal(0))
  848.         
  849.     ' Get the image pixels.
  850.     hbm = pic.Image
  851.     status = GetObject(hbm, BITMAP_SIZE, bm)
  852.     wid = bm.bmWidthBytes
  853.     hgt = bm.bmHeight
  854.     ReDim bytes(1 To wid, 1 To hgt)
  855.     status = GetBitmapBits(hbm, wid * hgt, bytes(1, 1))
  856.     ' Make the logical palette as big as possible.
  857.     logpal = pic.Picture.hPal
  858.     If ResizePalette(logpal, SysPalSize) = 0 Then
  859.         Beep
  860.         MsgBox "Error resizing logical palette.", _
  861.             vbExclamation
  862.         Exit Sub
  863.     End If
  864.     ' Blank the non-static colors.
  865.     For i = 0 To StaticColor1
  866.         syspal(i) = origpal(i)
  867.     Next i
  868.     For i = StaticColor1 + 1 To StaticColor2 - 1
  869.         With syspal(i)
  870.             .peRed = 0
  871.             .peGreen = 0
  872.             .peBlue = 0
  873.             .peFlags = PC_NOCOLLAPSE
  874.         End With
  875.     Next i
  876.     For i = StaticColor2 To 255
  877.         syspal(i) = origpal(i)
  878.     Next i
  879.     status = SetPaletteEntries(logpal, 0, SysPalSize, syspal(0))
  880.     ' Insert the non-static grays.
  881.     gray = 0
  882.     dgray = 255 / (StaticColor2 - StaticColor1 - 2)
  883.     For i = StaticColor1 + 1 To StaticColor2 - 1
  884.         C = gray
  885.         gray = gray + dgray
  886.         With syspal(i)
  887.             .peRed = C
  888.             .peGreen = C
  889.             .peBlue = C
  890.         End With
  891.     Next i
  892.     status = SetPaletteEntries(logpal, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, syspal(StaticColor1 + 1))
  893.     ' Realize the gray palette.
  894.     status = RealizePalette(pic.hdc)
  895.     pic.Refresh
  896. End Sub
  897. Private Sub mnuFileExit_Click()
  898.     Unload Me
  899. End Sub
  900. Private Sub mnuFileSaveBitmap_Click()
  901. Dim fname As String
  902.     ' Allow the user to pick a file.
  903.     On Error Resume Next
  904.     LoadDialog.filename = "*.BMP"
  905.     LoadDialog.Flags = cdlOFNOverwritePrompt + cdlOFNHideReadOnly
  906.     LoadDialog.ShowSave
  907.     If Err.Number = cdlCancel Then
  908.         Unload LoadDialog
  909.         Exit Sub
  910.     ElseIf Err.Number <> 0 Then
  911.         Unload LoadDialog
  912.         Beep
  913.         MsgBox "Error selecting file.", , vbExclamation
  914.         Exit Sub
  915.     End If
  916.     On Error GoTo 0
  917.     fname = LoadDialog.filename
  918.     SavePicture Pict.Image, fname
  919. End Sub
  920. ' ************************************************
  921. ' Select this choice.
  922. ' ************************************************
  923. Private Sub Scene_Click(index As Integer)
  924.     SceneChoice = index
  925. End Sub
  926.